<%
'RFC 2104 HMAC implementation for asp
Class THMAC
  '  Private Sub Class_Initialize() End Sub

    private function SHL(lValue, iShiftBits)
        if iShiftBits = 0 then
            SHL = lValue
            Exit Function
        elseif iShiftBits = 31 then
            if lValue And 1 then
                SHL = &H80000000
            else
                SHL = 0
            end if

            Exit Function
        elseif iShiftBits < 0 Or iShiftBits > 31 then
            Err.Raise 6
        end if

        if (lValue And 2^(31 - iShiftBits)) then
            SHL = ((lValue And (2^(31 - iShiftBits)-1)) * (2^iShiftBits)) Or &H80000000
        else
            SHL = (lValue And (2^(32 - iShiftBits)-1)) * 2^iShiftBits
        end if
    end function

    private function SHR(lValue, iShiftBits)
        if iShiftBits = 0 then
            SHR = lValue
            Exit Function
        elseif iShiftBits = 31 then
            if lValue And &H80000000 then
                SHR = 1
            else
                SHR = 0
            end if

            Exit Function
        elseif iShiftBits < 0 Or iShiftBits > 31 then
            Err.Raise 6
        end if

        SHR = (lValue And &H7FFFFFFE) \ (2^iShiftBits)

        if (lValue And &H80000000) then
            iShiftBits=iShiftBits-1
            SHR = SHR Or (&H40000000 \ (2^iShiftBits ))
        end if
    end function

    Private Function bytarray2binl (barray)
        Dim nblk,blks(),i
   
        nblk = SHR(ubound(barray) + 9, 6) + 1
        ReDim blks((nblk * 16)-1)

        For i = 0 To UBound(blks)
            blks(i) = 0
        Next

        For i = 0 To UBound(barray)
            blks(SHR(i,2)) = blks(SHR(i,2)) OR (SHL(barray(i) AND &HFF, ((i mod 4)*8)))
        Next

        blks(SHR(i,2)) = blks(SHR(i,2)) OR (SHL(&H80, ((i mod 4)*8)))
        blks(nblk*16-2) = (ubound(barray)+1) * 8
        bytarray2binl = blks
    end function

    Private Function binl2byt(binarray)
        Dim hex_tab,bytarray(),i
        ReDim bytarray(((UBound(binarray)+1)*4)-1)

        For i = 0 To ((UBound(binarray) +1) * 4) -1
            bytarray(i) = SHL((SHR(binarray(SHR(i,2)),(((i mod 4)*8)+4)) AND &H0f) ,4) OR (SHR(binarray(SHR(i,2)),((i mod 4)*8)) AND &H0f)
        Next

        binl2byt = bytarray
    end function

    private Function binl2hex(binarray)
        Dim str,i

        For i = 0 to ((UBound(binarray) +1) * 4) -1
            str = str & LCase(hex(SHR(binarray(SHR(i,2)),((i mod 4)*8) + 4) AND &Hf)) & lcase(hex(SHR(binarray(SHR(i, 2)), ((i mod 4) * 8)) AND &Hf))
        Next

        binl2hex = str
    end function

    Public Function Encrypt(ByRef a_oObj, key, text)
        Dim ipad(63),opad(63),idata(),odata(79)
        ReDim idata(63 + len(text))
        Dim i, innerhashout, hkey
        Dim sName, sResult

        Encrypt=null
        sName=TypeName(a_oObj)
        If sName<>"TMD5" And sName<>"TSHA1" AND sName<>"TSHA256" Then Exit Function End If
        hkey = key
        if Len(key) > 64 then hkey = a_oObj.Encrypt(key) end if

        For i = 0 to 63
            ipad(i) = &H36
            idata(i) = &H36
            odata(i) = &H5C
            opad(i) = &H5C
        Next

        For i = 0 To len(hkey)-1
            ipad(i) = ipad(i) XOR asc(mid(hkey,i+1,1))
            opad(i) = opad(i) XOR asc(mid(hkey,i+1,1))
            idata(i) = ipad(i) AND &HFF
            odata(i) = opad(i) AND &HFF
        Next

        For i = 0 To Len(text) -1
            idata(64 + i) = asc(mid(text,i+1,1)) AND &HFF
        Next

        innerhashout = binl2byt(a_oObj.EncryptArray(bytarray2binl(idata)))

        For i = 0 To 15
            odata(64+i) = innerhashout(i)
        Next

        sResult=Replace(binl2hex(a_oObj.EncryptArray(bytarray2binl(odata))),"00000000","")
        Encrypt = sResult
    end function
End Class
'
'Set cls_oObj=New TMD5
'sResult = cls_oObj.Encrypt("md5","apple")
'Response.Write("r1:" & sResult & "<br/>")

'a_sKey="hmac"
'If not a_sKey="" Then
'    Set oObj = New THMAC
                
'     sResult = oObj.Encrypt(cls_oObj,a_sKey,sResult)
'End If

'Response.Write("r2:" & sResult)
%>
